home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
H245.ZIP
/
NFSRC21.ZIP
/
POPADDER.PRG
< prev
next >
Wrap
Text File
|
1991-08-17
|
45KB
|
1,292 lines
/*
* File......: Popadder.prg
* Author....: Keith A. Wire
* CIS ID....: 73760,2427
* Date......: $Date: 17 Aug 1991 15:44:30 $
* Revision..: $Revision: 1.2 $
* Log file..: $Logfile: E:/nanfor/src/popadder.prv $
*
* This is an original work by Keith A. Wire and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* $Log: E:/nanfor/src/popadder.prv $
*
* Rev 1.2 17 Aug 1991 15:44:30 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.1 15 Aug 1991 23:04:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 14 Jun 1991 17:37:54 GLENN
* Initial revision.
*
*/
/*
* File......: Popadder.prg
* Author....: Keith A. Wire
* CIS ID....: 73760,2427
* Date......: $Date: 17 Aug 1991 15:44:30 $
* Revision..: $Revision: 1.2 $
* Log file..: $Logfile: E:/nanfor/src/popadder.prv $
*
* This is an original work by Keith A. Wire and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* $Log$
*
* Rev 1.0 14 Jun 1991 17:37:54 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_Adder()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Pop up a simple calculator
* $SYNTAX$
* FT_Adder()
* $ARGUMENTS$
* None
* $RETURNS$
* NIL .... but optionally places Total of calculation in active
* Get variable using oGet:VARPUT()
* $DESCRIPTION$
* PopAdder() gives you an adding machine inside your Clipper 5.01
* application. It has the basic functions add, subtract, multiply,
* and divide. You may move it from one side of the screen to the
* other. It even displays a scrollable tape, if you want it.
*
*
* The Help screen below gives a brief description of the operation
* of the adder.
*
*
* ┌─────── INSTRUCTIONS ───────┐
* │ │
* │ All number keys as usual │
* │ <+> <-> keys as usual │
* │ <SPACE>─┬─shift <+> to <*> │
* │ └─shift <-> to </> │
* │ <D> change decimal pt. │
* │ <M> move ADDER │
* │ <T> display tape │
* │ <S> scroll tape disp. │
* │ <DEL>───┬─1st Clear entry │
* │ └─2nd Clear ADDER │
* │ <ESC> to Quit │
* │ <F10> to Return Total │
* │ to program │
* │ │
* └──── Any Key to Continue ───┘
*
*
*
* A couple of notes about the adder:
*
*
* 1.) It was designed to be used on an Enhanced keyboard with
* separate <DELETE> key. <DELETE> is used to clear the adder.
* However, it will still work on a Standard keyboard.
*
* 2.) It uses the <SPACE> bar to shift from Add/Subtract
* mode to Multiply/Divide. That means the <+> and <-> keys
* become the <*> and </> keys.
*
* 3.) You do not have to display the tape. You may turn it on
* at any time by pressing <T>. You may SCROLL back through
* the tape once there are more than 16 entries in the
* adder, by pressing <S>.
*
* 4.) To Quit the Adder just press <ESC>. To return your Total
* to the application press <F10>. The adder will place the
* Total in the active GET variable using oGet:VarPut(). The
* adder will only return a Total to a numerical GET!
*
* 5.) There are many support functions that you might find
* interesting. They are part of my personal library, but
* are necessary to the operation of the adder.
* You might want to pull these out to reduce the overall
* size of the adder. Many are worth at least a little
* time studying.
*
* 6.) To make FT_Adder a Hot key from inside your application
* at the beginning of your application add the line:
*
* SET KEY K_ALT_A TO FT_Adder
*
* This will make <ALT-A> a key "Hot" and permit you to
* Pop - Up the adder from anywhere in the application.
*
* 7.) If you use FT_SINKEY(), you can even have active hotkeys
* in an INKEY().
*
*
*
*
* $EXAMPLES$
*
* $SEEALSO$
*
* $INCLUDE$
* INKEY.CH, SET.CH, SETCURS.CH, ACHOICE.CH
* $END$
*/
#include 'Inkey.ch'
#include 'Set.ch'
#include 'SetCurs.ch'
#include 'achoice.ch'
#define K_PLUS 43
#define K_MINUS 45
#define K_SPACE 32
#define nTotTran LEN(aTrans)
#define MUST_READ .T.
#define POP_ON .T.
#define POP_OFF .F.
#define B_DOUBLE '╔═╗║╝═╚║ '
#define B_SINGLE '┌─┐│┘─└│ '
// Set up manifest constants to access the window colors in the array aWinColor
#define W_BORDER 1
#define W_ACCENT 2
#define W_PROMPT 3
#define W_SCREEN 4
#define W_TITLE 5
#define W_VARIAB 6
#define W_CURR NIL
// Set up manifest constants to access the Standard screen colors in the array
// aStdColor
#define STD_ACCENT 1
#define STD_ERROR 2
#define STD_PROMPT 3
#define STD_SCREEN 4
#define STD_TITLE 5
#define STD_VARIABLE 6
#define STD_BORDER 7
/* This ASHRINK is by Rick Spence */
#define ASHRINK(ar) ASIZE(ar,LEN(ar)-1)
#command DISPMESSAGE <mess>,<t>,<l>,<b>,<r> => ;
_ftPushKeys(); KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_CTRL_W);;
MEMOEDIT(<mess>,<t>,<l>,<b>,<r>); _ftPopKeys()
/* This INKEY UDC was posted by Don Caton on NanForum... Thanks Don <g> */
#command INKEY [ <secs> ] TO <var> ;
=> ;
WHILE (.T.) ;;
<var> := Inkey([ <secs> ]) ;;
IF Setkey(<var>) # NIL ;;
Eval( Setkey(<var>), ProcName(), ProcLine(), #<var> ) ;;
ELSE ;;
EXIT ;;
END ;;
END
MEMVAR getlist
STATIC nTotal,nNumTotal,nSavTotal,cDefTotPict,cTotPict,lShowRight
STATIC nAddSpace,nTapeSpace,nTopTape,lClAdder,lDecSet,nDecDigit,nMaxDeci
STATIC lMultDiv,nAddMode,lSubRtn,cTapeScr,lTotalOk,lAddError
STATIC aTrans,lTape, nTopOS, nLeftOS, lNewNum, nSavSubTotal, lDivideErr
STATIC aHelpStack := {}, aKeys := {}
STATIC lStatMustRing := .T. // Change this to .F. if you don't
// want the bell on inputs
STATIC aWindow := {}, nWinColor := 0
STATIC aWinColor, aStdColor
#ifdef FT_TEST
FUNCTION TEST
LOCAL nSickHrs := 0, ;
nPersHrs := 0, ;
nVacaHrs := 0
aWinColor := { {'GR+/BG','GR+/G', 'B+/RB', 'G+/R'} , ;
{'R+/N', 'W+/RB','W+/BG','GR+/B'} , ;
{'GR+/N', 'GR+/N','GR+/N', 'GR+/N'} , ;
{ 'B/BG','BG+/G', 'W+/RB','BG+/R'} , ;
{ 'W+/BG', 'W+/G','GR+/RB', 'W+/R'} , ;
{'GR+/B', 'GR+/R', 'R+/B', 'W+/BG'},;
{ 'N/N', 'N/N', 'N/N', 'N/N'} }
aStdColor := { 'BG+*/RB' , ;
'GR+/R' , ;
'GR+/N' , ;
'W/B' , ;
'GR+/N' , ;
'GR+/GR' , ;
{ 'W+/B', 'W/B','G+/B','R+/B',;
'GR+/B','BG+/B','B+/B','G+/B'},;
'N/N' }
SET SCOREBOARD OFF
_ftSetScrColor(STD_SCREEN,STD_VARIABLE)
CLEAR SCREEN
SET KEY K_ALT_A TO FT_Adder // Make <ALT-A> call FT_Adder
* SIMPLE Sample of program data entry!
@ 12,5 SAY 'Please enter the total Sick, Personal, and Vacation hours.'
@ 15,22 SAY 'Sick hrs.'
@ 15,40 SAY 'Pers. hrs.'
@ 15,60 SAY 'Vaca. hrs.'
@ 23,20 SAY 'Press <ALT-A> to Pop - Up the Adder.'
@ 24,20 SAY 'Press <ESC> to Quit the adder Demo.'
DO WHILE .T. // Get the sick, personal, & vacation
@ 16,24 GET nSickHrs PICTURE '9999.999' // Normally I have a VALID()
@ 16,43 GET nPersHrs PICTURE '9999.999' // to make sure the value is
@ 16,63 GET nVacaHrs PICTURE '9999.999' // within the allowable range.
SET CURSOR ON // But, like I said it is a
CLEAR TYPEAHEAD // SIMPLE example <g>.
READ
SET CURSOR OFF
IF LASTKEY() == K_ESC // <ESC> - ABORT
CLEAR TYPEAHEAD
EXIT
ENDIF
ENDDO
SET CURSOR ON
SET KEY K_ALT_A // Reset <ALT-A>
RETURN NIL
#endif
FUNCTION FT_Adder // "KAW" ADDER
LOCAL cOldColor,nOldCurs,nOldDecim,nOldRow,nOldCol,nKey
LOCAL bOldF10,nOldLastKey, cMoveTotSubTot, cTotal
LOCAL oGet := GetActive()
aWinColor := { {'GR+/BG','GR+/G', 'B+/RB', 'G+/R'} , ;
{'R+/N', 'W+/RB','W+/BG','GR+/B'} , ;
{'GR+/N', 'GR+/N','GR+/N', 'GR+/N'} , ;
{ 'B/BG','BG+/G', 'W+/RB','BG+/R'} , ;
{ 'W+/BG', 'W+/G','GR+/RB', 'W+/R'} , ;
{'GR+/B', 'GR+/R', 'R+/B', 'W+/BG'},;
{ 'N/N', 'N/N', 'N/N', 'N/N'} }
aStdColor := { 'BG+*/RB' , ;
'GR+/R' , ;
'GR+/N' , ;
'W/B' , ;
'GR+/N' , ;
'GR+/GR' , ;
{ 'W+/B', 'W/B','G+/B','R+/B',;
'GR+/B','BG+/B','B+/B','G+/B'},;
'N/N' }
nOldLastKey := LASTKEY()
bOldF10 := SETKEY(K_F10,NIL)
aTrans := {}
SET KEY K_ALT_A TO // Turn off Adder
lDivideErr := .F.
cOldColor := SETCOLOR()
nOldCurs := SETCURSOR(SC_NONE)
nOldDecim := SET(_SET_DECIMALS,9)
nOldRow := ROW()
nOldCol := COL()
cDefTotPict:= '999999999999999999'
cTotPict := ''
nTotal := nNumTotal := nSavTotal := nKey := nDecDigit := nMaxDeci := 0
nSavSubTotal := 0
lNewNum := .F.
lShowRight := .T.
nTopOS := INT((MAXROW()-24)/2) // Using the TopOffSet & LeftOffSet
nLeftOS := INT((MAXCOL()-79)/2) // the Adder will always be centered
nAddSpace := IF(lShowRight,40,0)+nLeftOS
nTapeSpace := IF(lShowRight,0,40)+nLeftOS
cTapeScr := ''
nTopTape := 1
nAddMode := 1 // Start in ADD mode
lMultDiv := .F. // Start in ADD mode
lClAdder := .F. // Clear adder flag
lDecSet := .F. // Decimal ? - keyboard routine
lSubRtn := lTotalOk := lTape := lAddError := .F.
_ftAddScreen()
_ftChangeDec(2)
CLEAR TYPEAHEAD
DO WHILE .T. // Input key & test loop
INKEY 0 TO nKey
DO CASE
CASE UPPER(CHR(nKey)) $'1234567890.'
_ftEraseTotSubTot()
_ftProcessNumb(nKey)
CASE nKey == K_PLUS // <+> sign
_ftEraseTotSubTot()
_ftAddNum(nKey)
CASE nKey == K_MINUS // <-> sign
_ftEraseTotSubTot()
_ftAddNum(nKey)
CASE nKey == K_RETURN // <RTN> Total or Subtotal
_ftEraseTotSubTot()
_ftAddTotal()
CASE nKey == K_ESC // <ESC> Quit
_ftEraseTotSubTot()
SET(_SET_DECIMALS,nOldDecim)
SETCURSOR(nOldCurs)
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
ENDIF
_ftPopWin()
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
SETKEY(K_F10,bOldF10)
SET KEY K_ALT_A TO FT_Adder // Turn on Adder
RETU NIL
CASE nKey == 68 .OR. nKey == 100 // <D> Change number of decimal places
_ftChangeDec()
CASE nKey == 84 .OR. nKey == 116 // <T> Display Tape
_ftDisplayTape(nKey)
CASE nKey == 77 .OR. nKey == 109 // <M> Move Adder
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
ENDIF
IF LEFT(SAVESCREEN(8+nTopOS,26+nAddSpace,8+nTopOS,27+nAddSpace),1) ;
!= ' '
IF LEFT(SAVESCREEN(8+nTopOS,19+nAddSpace,8+nTopOS,20+nAddSpace),1) ;
== 'S'
cMoveTotSubTot := 'S'
ELSE
cMoveTotSubTot := 'T'
ENDIF
ELSE
cMoveTotSubTot := ' '
ENDIF
cTotal := _ftCharOdd(SAVESCREEN(5+nTopOS,8+nAddSpace,5+nTopOS,25+nAddSpace))
_ftPopWin() // Remove Adder
lShowRight := !lShowRight
nAddSpace := IF(lShowRight,40,0)+nLeftOS
nTapeSpace := IF(lShowRight,0,40)+nLeftOS
_ftAddScreen()
_ftDispTotal()
IF lTape
lTape := .F.
_ftDisplayTape(nKey)
ENDIF
@ 5+nTopOS, 8+nAddSpace SAY cTotal
IF !EMPTY(cMoveTotSubTot)
_ftSetWinColor(W_CURR,W_SCREEN)
@ 8+nTopOS,18+nAddSpace SAY IF(cMoveTotSubTot=='T', ' <TOTAL>', ;
'<SUBTOTAL>')
_ftSetWinColor(W_CURR,W_PROMPT)
ENDIF
CASE (nKey == 83 .OR. nKey == 115) .AND. lTape // <S> Scroll display of tape
IF nTotTran>16 // We need to scroll
SETCOLOR('GR+/W')
@ 21+nTopOS,8+nTapeSpace SAY ' '+CHR(24)+CHR(25)+'-SCROLL <ESC>-QUIT '
SETCOLOR('N/W,W+/N')
ACHOICE(5+nTopOS,7+nTapeSpace,20+nTopOS,31+nTapeSpace,aTrans,.T., ;
'__ftAdderTapeUDF',nTotTran,20)
SETCOLOR('R+/W')
@ 21+nTopOS,8+nTapeSpace TO 21+nTopOS,30+nTapeSpace
_ftSetWinColor(W_CURR,W_PROMPT)
CLEAR TYPEAHEAD
ELSE
_ftError('but there are '+IF(nTotTran>0,'only '+LTRIM(;
STR(nTotTran,3,0)),'no')+' transactions entered so far. '+;
'No need to scroll!')
ENDIF
CASE nKey == K_SPACE // Space bar - Shift to Multiply/Divide
_ftEraseTotSubTot()
_ftShiftAdd()
CASE nKey == 7 // Delete - Clear adder
_ftEraseTotSubTot()
_ftClearAdder()
CASE nKey == K_F1 // <F1> Help
_ftAddHelp()
CASE nKey == K_F10 // <F10> Quit - Return total
IF lTotalOk // Did they finish the calculation
IF oGet != NIL .AND. oGet:TYPE == 'N'
SET(_SET_DECIMALS,nOldDecim)
SETCURSOR(nOldCurs)
IF lTape
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
ENDIF
_ftPopWin()
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
SETKEY(K_F10,bOldF10)
SET KEY K_ALT_A TO FT_Adder // Turn on Adder
oGet:VARPUT(nSavTotal)
RETU NIL
ELSE
_ftError('but I can not return the total from the '+;
'adder to this variable. You must quit the adder using'+;
' the <ESC> key and then enter the total manually.')
ENDIF
ELSE
_ftError('the calculation is not finished yet! You must have'+;
' a TOTAL before you can return it to the program.')
ENDIF
ENDCASE
ENDDO (WHILE .T. Data entry from keyboard)
RETURN NIL
**************
STATIC FUNCTION _ftAddScreen // Part of "KAW" ADDER
LOCAL nCol
_ftPushWin(2+nTopOS,2+nAddSpace,22+nTopOS,30+nAddSpace,' Adder ', ;
'<F-1> for Help',,B_DOUBLE)
nCol := 5+nAddSpace
@ 9+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
@ 10+nTopOS, nCol SAY '│ │ │ │ │ │ │ │'
@ 11+nTopOS, nCol SAY '└───┘ └───┘ └───┘ └───┘'
@ 12+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
@ 13+nTopOS, nCol SAY '│ │ │ │ │ │ │ │'
@ 14+nTopOS, nCol SAY '└───┘ └───┘ └───┘ └───┘'
@ 15+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
@ 16+nTopOS, nCol SAY '│ │ │ │ │ │ │ │'
@ 17+nTopOS, nCol SAY '└───┘ └───┘ └───┘ │ │'
@ 18+nTopOS, nCol SAY '┌─────────┐ ┌───┐ │ │'
@ 19+nTopOS, nCol SAY '│ │ │ │ │ │'
@ 20+nTopOS, nCol SAY '└─────────┘ └───┘ │ │'
@ 21+nTopOS, nCol SAY ' └───┘'
_ftSetWinColor(W_CURR,W_TITLE)
nCol := 7+nAddSpace
@ 10+nTopOS, nCol SAY '7'
@ 13+nTopOS, nCol SAY '4'
@ 16+nTopOS, nCol SAY '1'
nCol := 13+nAddSpace
@ 10+nTopOS,nCol SAY '8'
@ 13+nTopOS,nCol SAY '5'
@ 16+nTopOS,nCol SAY '2'
nCol := 19+nAddSpace
@ 10+nTopOS,nCol SAY '9'
@ 13+nTopOS,nCol SAY '6'
@ 16+nTopOS,nCol SAY '3'
@ 19+nTopOS,nCol SAY '.'
@ 19+nTopOS,10+nAddSpace SAY '0'
nCol := 25+nAddSpace
IF lMultDiv
@ 10+nTopOS,nCol SAY '÷'
@ 13+nTopOS,nCol SAY 'X'
@ 18+nTopOS,nCol SAY '='
ELSE
@ 10+nTopOS,nCol SAY '-'
@ 13+nTopOS,nCol SAY '+'
@ 17+nTopOS,nCol SAY ''
@ 19+nTopOS,nCol SAY '*'
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
@ 3+nTopOS,6+nAddSpace,7+nTopOS,27+nAddSpace BOX B_DOUBLE
RETURN NIL
**************
STATIC FUNCTION _ftChangeDec(nNumDec) // Change the decimal position in the
LOCAL y // display
IF nNumDec == NIL
nNumDec := 0
nNumDec := _ftQuestion('How many decimals do you want to display?',nNumDec,;
'9',{|oGet| _ftValDeci(oGet)},MUST_READ)
ENDIF
cTotPict := _ftPosRepl(cDefTotPict,'.',18-ABS(nNumDec))
FOR y=14-ABS(nNumDec) TO 2 STEP -4
cTotPict := _ftPosRepl(cTotPict,',',y)
NEXT
nMaxDeci := nNumDec
_ftDispTotal()
RETURN NIL
**************
STATIC FUNCTION _ftDispTotal // Display total number to Adder Window
LOCAL cTotStr
IF nTotal>VAL(_ftCharRem(',',cTotPict)) // Part of "KAW" ADDER
cTotStr := _ftStuffComma(LTRIM(STR(nTotal)))
_ftError('but that number is to big to display! '+;
'I believe the answer was '+cTotStr+'.')
@ 5+nTopOS, 8+nAddSpace SAY ' **** ERROR ****'
lAddError := .T.
_ftUpdateTrans(.T.)
_ftClearAdder()
nTotal := 0
nNumTotal := 0
lAddError := .F.
ELSE
@ 5+nTopOS, 8+nAddSpace SAY nTotal PICTURE cTotPict
ENDIF
RETURN NIL
**************
STATIC FUNCTION _ftDispSubTot // Display subtotal number
LOCAL cStotStr
IF nNumTotal>VAL(_ftCharRem(',',cTotPict))
cStotStr := _ftStuffComma(LTRIM(STR(nNumTotal)))
_ftError('but that number is to big to display! '+;
'I believe the answer was '+cStotStr+'.')
@ 5+nTopOS, 8+nAddSpace SAY ' **** ERROR ****'
lAddError := .T.
_ftUpdateTrans(.T.,nNumTotal)
_ftClearAdder()
nTotal := 0
nNumTotal := 0
lAddError := .F.
ELSE
@ 5+nTopOS, 8+nAddSpace SAY nNumTotal PICTURE cTotPict
ENDIF
RETURN NIL
**************
STATIC FUNCTION _ftProcessNumb(nKey) // Act on NUMBER key pressed
LOCAL nNum
lTotalOk := .F.
lClAdder := .F. // Reset the Clear flag
lAddError := .F. // Reset adder error flag
IF nKey=46 // Period (.) decimal point
IF lDecSet // Has decimal already been set
_ftRingBell(.T.)
ELSE
lDecSet := .T.
ENDIF
ELSE // It must be a number input
lNewNum := .T.
nNum := nKey-48
IF lDecSet // Decimal set
IF nDecDigit<nMaxDeci // Check how many decimals they are allowed
nDecDigit := ++nDecDigit
nNumTotal := nNumTotal+nNum/(10**nDecDigit)
ENDIF
ELSE
nNumTotal := nNumTotal*10+nNum
ENDIF
ENDIF
_ftDispSubTot()
RETURN NIL
**************
STATIC FUNCTION _ftShiftAdd // They pressed the space bar
LOCAL nCol
nCol := 25+nAddSpace
_ftSetWinColor(W_CURR,W_TITLE)
IF lMultDiv // toggle add/subt for mult/divide
lMultDiv := .F.
@ 10+nTopOS,nCol SAY '-'
@ 13+nTopOS,nCol SAY '+'
@ 18+nTopOS,nCol SAY ' '
@ 17+nTopOS,nCol SAY ''
@ 19+nTopOS,nCol SAY '*'
ELSE
lMultDiv := .T.
@ 10+nTopOS,nCol SAY '÷'
@ 13+nTopOS,nCol SAY 'X'
@ 18+nTopOS,nCol SAY '='
@ 17+nTopOS,nCol SAY ' '
@ 19+nTopOS,nCol SAY ' '
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL
**************
STATIC FUNCTION _ftAddTotal // Enter key - SUBTOTAL\TOTAL
lDecSet := .F.
nDecDigit := 0
lClAdder := .F. // Reset the Clear flag
IF lSubRtn // If this was the second time they
IF !lMultDiv
_ftSetWinColor(W_CURR,W_SCREEN)
@ 8+nTopOS,18+nAddSpace SAY ' <TOTAL>'
_ftSetWinColor(W_CURR,W_PROMPT)
_ftUpdateTrans(.T.)
_ftDispTotal()
lSubRtn := .F. // pressed the total key reset everyting
nSavTotal := nTotal
nTotal := 0
lTotalOk := .T.
ENDIF
ELSE // This was the first time they pressed
IF !lMultDiv .AND. LASTKEY() == K_RETURN // total key
lSubRtn := .T.
ENDIF
IF _ftRoundIt(nTotal,nMaxDeci)!=0 .OR. _ftRoundIt(nNumTotal,nMaxDeci)!=0
IF !lMultDiv
_ftSetWinColor(W_CURR,W_SCREEN)
@ 8+nTopOS,18+nAddSpace SAY '<SUBTOTAL>'
_ftSetWinColor(W_CURR,W_PROMPT)
ENDIF
IF _ftRoundIt(nNumTotal,nMaxDeci)!=0
lSubRtn := .F.
_ftUpdateTrans(.F.,nNumTotal)
ENDIF
IF !lMultDiv
lSubRtn := .T. // total key
ENDIF
IF nAddMode == 1 // Add
nTotal := nTotal+nNumTotal
ELSEIF nAddMode == 2 // Subtract
nTotal := nTotal-nNumTotal
ELSEIF nAddMode == 3 // Multiply
nTotal := nTotal*nNumTotal
ELSEIF nAddMode == 4 // Divide
nTotal := _ftDivide(nTotal,nNumTotal)
IF lDivideErr
_ftError("but you can't divide by ZERO!")
lDivideErr := .F.
ENDIF
ENDIF
ENDIF
_ftDispTotal()
IF lMultDiv // This was a multiply or divide
_ftSetWinColor(W_CURR,W_SCREEN)
@ 8+nTopOS,18+nAddSpace SAY ' <TOTAL>'
_ftSetWinColor(W_CURR,W_PROMPT)
lSubRtn := .F. // pressed the total key reset everyting
IF !lTotalOk // If you haven't printed total DO-IT
lTotalOk := .T.
_ftUpdateTrans(.F.)
ENDIF
nNumTotal := 0
nSavTotal := nTotal
nTotal := 0
ELSE
IF !lTotalOk // If you haven't printed total DO-IT
_ftUpdateTrans(.F.)
nNumTotal := 0
ENDIF
ENDIF
ENDIF
RETURN NIL
**************
STATIC FUNCTION _ftAddNum(nKey) // Process + or - keypress
lTotalOk := .F.
lDecSet := .F.
nDecDigit := 0
lSubRtn := .F.
IF lMultDiv
// They pressed the + or - key to process the previous total
IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
nNumTotal := nSavTotal
ENDIF
// Get the first number of the product or division
IF _ftRoundIt(nTotal,nMaxDeci)==0
IF nKey == K_PLUS // Setup mode
nAddMode := 3
_ftUpdateTrans(.F.,nNumTotal)
ELSEIF nKey == K_MINUS
nAddMode := 4
_ftUpdateTrans(.F.,nNumTotal)
ENDIF
nTotal := nNumTotal
nNumTotal := 0
ELSE
IF nKey == K_PLUS // Multiply
nAddMode := 3
_ftUpdateTrans(.F.,nNumTotal)
nTotal := nTotal*nNumTotal
nNumTotal := 0
ELSEIF nKey == K_MINUS // Divide
nAddMode := 4
_ftUpdateTrans(.F.,nNumTotal)
nTotal:=_ftDivide(nTotal,nNumTotal)
IF lDivideErr
_ftError("but you can't divide by ZERO!")
lDivideErr := .F.
ENDIF
nNumTotal := 0
ENDIF
ENDIF
ELSE
// They pressed the + or - key to process the previous total
IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
nNumTotal := nSavTotal
lNewNum := .T.
ENDIF
IF nKey == K_PLUS // Add
nAddMode := 1
IF !lNewNum // They pressed + again to add the same
nNumTotal := nSavSubTotal // number without re-entering
ENDIF
_ftUpdateTrans(.F.,nNumTotal)
nTotal := nTotal+nNumTotal
lNewNum := .F.
nSavSubTotal := nNumTotal // Save this number in case they just press + or -
nNumTotal := 0
ELSEIF nKey == K_MINUS // Subtract
nAddMode := 2
IF !lNewNum // They pressed + again to add the same
nNumTotal := nSavSubTotal // number without re-entering
lNewNum := .T.
ENDIF
_ftUpdateTrans(.F.,nNumTotal)
nTotal := nTotal-nNumTotal
lNewNum := .F.
nSavSubTotal := nNumTotal // Save this number in case they just press + or -
nNumTotal := 0
ENDIF
ENDIF
_ftDispTotal()
RETURN NIL
**************
STATIC FUNCTION _ftAddHelp // Help window Part of "KAW" ADDER
LOCAL nKey2
_ftPushWin(8+nTopOS,27+nLeftOS,23+nTopOS,57+nLeftOS,'INSTRUCTIONS','Any Key to Continue')
@ 9+nTopOS,30+nLeftOS SAY 'All number keys as usual'
@ 10+nTopOS,30+nLeftOS SAY '<+> <-> keys as usual'
@ 11+nTopOS,30+nLeftOS SAY '<SPACE>─┬─shift <+> to <*>'
@ 12+nTopOS,30+nLeftOS SAY ' └─shift <-> to </>'
@ 13+nTopOS,30+nLeftOS SAY ' <D> change decimal pt.'
@ 14+nTopOS,30+nLeftOS SAY ' <M> move ADDER '
@ 15+nTopOS,30+nLeftOS SAY ' <T> display tape'
@ 16+nTopOS,30+nLeftOS SAY ' <S> scroll tape disp.'
@ 17+nTopOS,30+nLeftOS SAY '<DEL>───┬─1st Clear entry'
@ 18+nTopOS,30+nLeftOS SAY ' └─2nd Clear ADDER'
@ 19+nTopOS,30+nLeftOS SAY '<ESC> to Quit'
@ 20+nTopOS,30+nLeftOS SAY '<F10> to Return Total'
@ 21+nTopOS,30+nLeftOS SAY ' to program'
INKEY 0 TO nKey2
_ftPopWin()
RETURN NIL
**************
STATIC FUNCTION _ftClearAdder // Clear entry / Clear Adder Part of "KAW" ADDER
lDecSet := .F.
nDecDigit := 0
IF lClAdder // If it has alredy been pressed once
nTotal := 0 // then we are clearing the total
nSavTotal := 0
_ftUpdateTrans()
lClAdder := .F.
_ftDispTotal()
ELSE
nNumTotal := 0 // Just clearing the last entry
lClAdder := .T.
_ftDispSubTot()
ENDIF
RETURN NIL
**************
STATIC FUNCTION _ftDisplayTape(nKey) // Display tape Part of "KAW" ADDER
LOCAL nDispTape
IF (nKey == 84 .OR. nKey == 116) .AND. lTape // Stop displaying tape
lTape := .F.
RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
RETU NIL
ENDIF
IF lTape // Are we in the display mode
SETCOLOR('N/W')
SCROLL(5+nTopOS,7+nTapeSpace,20+nTopOS,31+nTapeSpace,1)
IF nTotTran>0 // Have any transactions been entered yet?
@ 20+nTopOS,7+nTapeSpace SAY aTrans[nTotTran]
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
ELSE // Start displaying tape
lTape := .T.
SETCOLOR('N/W')
cTapeScr := SAVESCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace)
_ftShadow(22+nTopOS,8+nTapeSpace,22+nTopOS,34+nTapeSpace)
_ftShadow(5+nTopOS,33+nTapeSpace,21+nTopOS,34+nTapeSpace)
SETCOLOR('R+/W')
@ 4+nTopOS,6+nTapeSpace,21+nTopOS,32+nTapeSpace BOX B_SINGLE
SETCOLOR('GR+/W')
@ 4+nTopOS,17+nTapeSpace SAY ' TAPE '
SETCOLOR('N/W')
IF nTotTran>15
nTopTape := nTotTran-15
ENDIF
FOR nDispTape=nTotTran TO nTopTape STEP -1
@ 20+nDispTape-nTotTran+nTopOS,7+nTapeSpace SAY aTrans[nDispTape]
NEXT
ENDIF
_ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL
**************
STATIC FUNCTION _ftUpdateTrans(lTypeTotal,nAmount) // Update transactions array Part of "KAW" ADDER
nAmount := IF(nAmount==NIL,0,nAmount)
IF lClAdder // Clear the adder (they pressed <DEL> twice
AADD(aTrans,STR(0,20,nMaxDeci)+' C')
IF lTape // If there is a tape Show Clear
_ftDisplayTape()
ENDIF
RETU NIL
ENDIF
IF lTypeTotal // If lTypeTotal=.T. Update from total
AADD(aTrans,STR(IF(PCOUNT()==1,nTotal,nAmount),20,nMaxDeci)+' *')
aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran],.T.)+IF(lAddError,'ER','')
ELSE // If lTypeTotal=.F. Update from nNumTotal
AADD(aTrans,STR(IF(PCOUNT()==1,nTotal,nAmount),20,nMaxDeci)+;
IF(lSubRtn,' ',IF(nAddMode==1,' +',IF(nAddMode==2,' -',IF;
(lTotalOk,' =',IF(nAddMode==3,' X',' ÷'))))))
aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran],.T.)+IF(lAddError,'ER','')
ENDIF
IF lTape
_ftDisplayTape()
ENDIF
RETURN NIL
**************
FUNCTION __ftAdderTapeUDF(mode,cur_elem,rel_pos) // User function for ACHOICE in "KAW" ADDER
LOCAL nKey,nRtnVal
STATIC ac_exit_ok := .F.
DO CASE
CASE mode == AC_EXCEPT
nKey := LASTKEY()
DO CASE
CASE nKey == 30
nRtnVal := AC_CONT
CASE nKey == K_ESC
KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_RETURN) // Go to last item
ac_exit_ok := .T.
nRtnVal := AC_CONT
CASE ac_exit_ok
nRtnVal := AC_ABORT
ac_exit_ok := .F.
OTHERWISE
nRtnVal := AC_CONT
ENDCASE
OTHERWISE
nRtnVal := AC_CONT
ENDCASE
RETURN nRtnVal
*************
STATIC FUNCTION _ftValDeci(oGet)
IF oGet:VarGet()>8
_ftError('no more than 8 decimal places please!')
RETU .F.
ENDIF
RETURN .T.
*************
STATIC FUNCTION _ftDivide(nNumerator,nDenominator) // Check divide by zero not allowed
IF nDenominator==0.0
lDivideErr := .T.
RETU 0
ELSE
lDivideErr := .F.
ENDIF
RETURN(nNumerator/nDenominator)
**************
STATIC FUNCTION _ftStuffComma(cStrToStuff,lTrimStuffedStr) // Stuff comma into tape display Part of "KAW" ADDER
LOCAL nDecPosit,x
lTrimStuffedStr := IF(lTrimStuffedStr=NIL,.F.,lTrimStuffedStr)
IF !('.' $ cStrToStuff)
cStrToStuff := _ftPosIns(cStrToStuff,'.',IF('C'$cStrToStuff .OR. 'E'$cStrToStuff;
.OR. '+'$cStrToStuff .OR. '-'$cStrToStuff .OR. 'X'$cStrToStuff .OR. ;
'*'$cStrToStuff .OR. ''$cStrToStuff .OR. '÷'$cStrToStuff .OR. '='$cStrToStuff,;
LEN(cStrToStuff)-1,LEN(cStrToStuff)+1))
ENDIF
nDecPosit := AT('.',cStrToStuff)
IF LEN(LEFT(LTRIM(_ftCharRem('-',cStrToStuff)),;
AT('.',LTRIM(_ftCharRem('-',cStrToStuff)))-1))>3
IF lTrimStuffedStr // Do we trim the number each time we insert a comma
FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -4
cStrToStuff := SUBSTR(_ftPosIns(cStrToStuff,',',x),2)
NEXT
ELSE
FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -3
cStrToStuff := _ftPosIns(cStrToStuff,',',x)
NEXT
ENDIF
ENDIF
RETURN(cStrToStuff)
**************
STATIC FUNCTION _ftEraseTotSubTot
_ftSetWinColor(W_CURR,W_SCREEN)
@ 8+nTopOS,18+nAddSpace SAY ' ' // Clear <TOTAL> - <SUBTOTAL>
_ftSetWinColor(W_CURR,W_PROMPT)
RETURN NIL
*************
***** "KAW Adder Support functions *******
STATIC FUNCTION _ftRingBell(lMustRing) // I can turn off the bell!
lMustRing := IF(lMustRing == NIL, .F., lMustRing)
IF lMustRing .OR. lStatMustRing
?? CHR(7)
ENDIF
RETURN NIL
**************
STATIC FUNCTION _ftError(cMessage) // Print error messages
LOCAL nOldRow,nOldCol,nOldCurs,nTop,nLeft,nBot,nRight,cOldColor
LOCAL nOldLastKey,cErrorScr,nMessLen,nWide,nNumRows
nOldLastKey := LASTKEY()
nOldRow := ROW()
nOldCol := COL()
nOldCurs := SETCURSOR(SC_NONE)
cOldColor:= _ftSetScrColor(STD_ERROR)
cMessage := "I'm sorry but, "+cMessage
nMessLen := LEN(cMessage)
nWide := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
nNumRows := MLCOUNT(cMessage,nWide)
nTop := 15-nNumRows
nBot := nTop+3+nNumRows
nLeft := 40-_ftRoundIt(nWide/2,0)-2
nRight := nLeft+nWide+4
cErrorScr:=SAVESCREEN(nTop,nLeft,nBot+1,nRight+2)
_ftShadow(nBot+1,nLeft+2,nBot+1,nRight+2,8)
_ftShadow(nTop+1,nRight+1,nBot ,nRight+2,8)
@ nTop,nLeft,nBot,nRight BOX B_SINGLE
@ nTop,nLeft+INT(nWide/2)-1 SAY ' ERROR '
@ nBot-1,nLeft+INT(nWide-28)/2+3 SAY 'Press any key to continue...'
DISPMESSAGE cMessage,nTop+1,nLeft+3,nBot-2,nRight-3
TONE(70,5)
INKEY(0)
RESTSCREEN(nTop,nLeft,nBot+1,nRight+2,cErrorScr)
SETCURSOR(nOldCurs)
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
RETURN NIL
**************
STATIC FUNCTION _ftCountLeft(cString,dummy) // Returns the number of spaces on
RETURN(LEN(cString)-LEN(LTRIM(cString))) // the Left side of the String
**************
STATIC FUNCTION _ftPosRepl(cString,cChar,posit) // Replace a Character in a
RETURN(STRTRAN(cString,'9',cChar,posit,1)+'') // String
**************
STATIC FUNCTION _ftPosIns(cString,cChar,posit) // Insert a Character in a
RETURN(LEFT(cString,posit-1)+cChar+SUBSTR(cString,posit)) // String
**************
STATIC FUNCTION _ftCharRem(cChar,cString) // Removes character from string
RETURN(STRTRAN(cString,cChar))
**************
/* _ftQuestion(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop,cHelp) ;
* -->xVarVal
*
* Push a Question Box on the screen and get the answer with a local
* variable, and return their answer
*
* cMessage -> Message printed above variable that describes explains
* what they are getting
* xVarVal -> Initial value of the variable Data types C,N,L,D
* cPict -> Picture for GET - Optional
* bValid -> Valid Block - Optional
* lNoESC -> When .T. they cannot <ESC>, default .F. - Optional
* nWinColor -> Window color, default next window color - Optional
* nTop -> Top row of window, default Center of screen - Optional
* cHelp -> If passed pushes the specific help variable to help stack
* If Not passed pushes the variable name 'NOQuHelp' - Opt.
*/
STATIC FUNCTION _ftQuestion(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop)
LOCAL nOldRow, nOldCol, cOldColor, nMessLen, nWide, nNumRows, nBottom, nLeft
LOCAL nRight, oNewGet, nNumMessRow, nLenLastRow, lGetOnNextLine, nOldCurs
LOCAL cVarType := VALTYPE(xVarVal)
LOCAL nVarLen := IF(cVarType='C',LEN(xVarVal),IF(cVarType='D',8, ;
IF(cVarType='L',1,IF(cVarType='N',IF(cPict=NIL,9, ;
LEN(cPict)),0))))
LOCAL nOldLastKey := LASTKEY()
MEMVAR GETLIST
nOldRow := ROW()
nOldCol := COL()
nOldCurs := SETCURSOR(SC_NONE)
cOldColor := SETCOLOR()
lNoESC := IF(lNoESC==NIL,.F.,lNoESC)
nMessLen := LEN(cMessage)+nVarLen+1
nWide := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
nNumMessRow := MLCOUNT(cMessage,nWide)
nLenLastRow := LEN(TRIM(MEMOLINE(cMessage,nWide,nNumMessRow)))
lGetOnNextLine := (nLenLastRow + nVarLen) > nWide
nNumRows := nNumMessRow + IF(lGetOnNextLine,1,0)
nTop := IF(nTop=NIL,INT((MAXROW() - nNumRows)/2),nTop) // Center it in the screen
nBottom := nTop+nNumRows+1
nLeft := INT((MAXCOL()-nWide)/2)-4
nRight := nLeft+nWide+4
_ftPushWin(nTop,nLeft,nBottom,nRight,'QUESTION ?',IF(VALTYPE(xVarVal)='C' ;
.AND. nVarLen>nWide,CHR(27)+' scroll '+ CHR(26),NIL),nWinColor)
DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2
oNewGet := GetNew( IF(lGetOnNextLine,Row()+1,Row()), ;
IF(lGetOnNextLine,nLeft+2,Col()+1), ;
{|x| IF(PCOUNT() > 0, xVarVal := x, xVarVal)}, ;
'xVarVal' )
// If the input line is character & wider than window SCROLL
IF lGetOnNextLine .AND. VALTYPE(xVarVal)='C' .AND. nVarLen>nWide
oNewGet:Picture := '@S'+LTRIM(STR(nWide,4,0))+IF(cPict=NIL,'',' '+cPict)
ENDIF
IF cPict != NIL // Use the picture they passed
oNewGet:Picture := cPict
ELSE // Else setup default pictures
IF VALTYPE(xVarVal)='D'
oNewGet:Picture := '99/99/99'
ELSEIF VALTYPE(xVarVal)='L'
oNewGet:Picture := 'Y'
ELSEIF VALTYPE(xVarVal)='N'
oNewGet:Picture := '999999.99' // Guess that they are inputting dollars
ENDIF
ENDIF
oNewGet:PostBlock := IF(bValid=NIL,NIL,bValid)
oNewGet:Display()
_ftRingBell()
DO WHILE .T. // Loop so we can check for <ESC>
// without reissuing the gets
ReadModal({oNewGet})
IF LASTKEY() == K_ESC .AND. lNoESC // They pressed <ESC>
_ftError('you cannot Abort! Please enter an answer.')
ELSE
EXIT
ENDIF
ENDDO
_ftPopWin()
SETCURSOR(nOldCurs)
SETCOLOR(cOldColor)
SETPOS(nOldRow,nOldCol)
_ftSetLastKey(nOldLastKey)
RETURN xVarVal
/* _ftSetLastKey(nLastKey) -- NIL
* Sets the LASTKEY() value to the vlaue nLastKey. I use this in most of my
* Pop-Up routines to reset the origional value of LASTKEY() when quitting.
*
*/
STATIC FUNCTION _ftSetLastKey(nLastKey)
_ftPushKeys()
KEYBOARD CHR(nLastKey)
INKEY()
_ftPopKeys()
RETURN NIL
***************
/* _ftPushKeys --> NIL
* Push any keys in the Keyboard buffer on the array aKeys[]
*/
STATIC FUNCTION _ftPushKeys
DO WHILE NEXTKEY() != 0
AADD(aKeys,INKEY())
ENDDO
RETURN NIL
/* _ftPopKeys() --> NIL
* Restore the keyboard with any keystrokes that were saved with _ftPushKeys
*/
STATIC FUNCTION _ftPopKeys
LOCAL cKeys := ''
IF LEN(aKeys) != 0
AEVAL(aKeys, {|elem| cKeys += CHR(elem)})
ENDIF
KEYBOARD cKeys
aKeys := {}
RETURN NIL
/* _ftActiveWinNum() --> nWinColor
* Return the currently active window color nWinColor which is a STATIC
* variable in the WINDOW.PRG. This gives access to any routine using
* windows.
* */
STATIC FUNCTION _ftActiveWinNum
RETURN(nWinColor)
**************
/* _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel) --> cOldColor
* Set the screen colors to the colors requested for the window
* requested. If the window number is not passed use the currently active
* window number nWinColor.
* */
STATIC FUNCTION _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel)
nWin := IF(nWin=NIL,nWinColor,nWin)
nStd := IF(nStd=NIL,7,nStd)
nEnh := IF(nEnh=NIL,7,nEnh)
nBord := IF(nBord=NIL,7,nBord)
nBack := IF(nBack=NIL,7,nBack)
nUnsel:= IF(nUnsel=NIL,nEnh,nUnsel)
RETURN SETCOLOR(aWinColor[nStd,nWin]+','+aWinColor[nEnh,nWin]+','+;
aWinColor[nBord,nWin]+','+aWinColor[nBack,nWin]+','+aWinColor[nUnsel,nWin])
**************
/* _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel) --> cOldColor
* Set the standard screen colors to the color requested.
* */
STATIC FUNCTION _ftSetScrColor(nStd,nEnh,nBord,nBack,nUnsel)
nStd := IF(nStd=NIL,8,nStd)
nEnh := IF(nEnh=NIL,8,nEnh)
nBord := IF(nBord=NIL,8,nBord)
nBack := IF(nBack=NIL,8,nBack)
nUnsel:= IF(nUnsel=NIL,nEnh,nUnsel)
RETURN SETCOLOR(aStdColor[nStd]+','+aStdColor[nEnh]+','+aStdColor[nBord]+','+;
aStdColor[nBack]+','+aStdColor[nUnsel])
**************
/* _ftSetBordColor(nBorder) --> cOldColor
* Set the Color to the Border color they requested and return the previous
* color setting.
* */
STATIC FUNCTION _ftSetBordColor(nBorder)
RETURN SETCOLOR(aStdcolor[8,nBorder])
**************
/* _ftNextWinColor() --> nWinColor
* Increment the active window color number and return the current value.
* If we are already on window #4 restart count by using # 1.
* */
STATIC FUNCTION _ftNextWinColor
RETURN nWinColor := (IF(nWinColor<4,nWinColor+1,1))
**************
/* _ftLastWinColor() --> nWinColor
* Decrement the active window color number and return the current value.
* If we are already on window #1 restart count by using # 4.
* */
STATIC FUNCTION _ftLastWinColor
RETURN nWinColor := IF(nWinColor=1,4,nWinColor-1)
*******************
/* _ftPushWin(t,l,b,r,cTitle,cBotTitle,w_color,cTypeBord) --> NIL
* Push a new window on the screen in the position t,l,b,r and if cTitle
* is not NIL print the title for the window in centered in the top line
* of the box. Simillarly do the same for cBotTitle. If w_color=NIL get
* the next window color and use it for all the colors. If cTypeBord=NIL
* use the single line border, else use the one they requested. Push the
* window coordinates, the color number, the SAVESCREEN() value, and
* whether they picked the window color they wanted to use.
* If lAutoWindow=.F. then the window color was incremented and we will
* will restore the color number when we pop the window off.
* */
STATIC FUNCTION _ftPushWin(t,l,b,r,cTitle,cBotTitle,w_color,cTypeBord)
LOCAL lAutoWindow := IF(w_color=NIL,.T.,.F.)
w_color := IF(w_color=NIL,_ftNextWinColor(),w_color)
AADD(aWindow,{t,l,b,r,w_color,SAVESCREEN(t,l,b+1,r+2),lAutoWindow})
_ftShadow(b+1,l+2,b+1,r+2)
_ftShadow(t+1,r+1,b,r+2)
_ftSetWinColor(w_color,W_BORDER)
@ t,l,b,r BOX IF(cTypeBord=NIL,B_SINGLE,cTypeBord)
IF cTitle!=NIL
_ftSetWinColor(w_color,W_TITLE)
_ftWinTitle(cTitle)
ENDIF
IF cBotTitle!=NIL
_ftSetWinColor(w_color,W_TITLE)
_ftWinTitle(cBotTitle,'bot')
ENDIF
_ftSetWinColor(w_color,W_SCREEN,W_VARIAB)
@ t+1,l+1 CLEAR TO b-1,r-1
RETURN NIL
*******************
/* _ftPopWin() --> NIL
* Pop the currently active window off the screen by restoring it from the
* aWindow Array and if they pushed a new window automatically selecting the
* color we will roll back the current window setting using _ftLastWinColor()
* and reset the color to the color setting when window was
* pushed.
* */
STATIC FUNCTION _ftPopWin
LOCAL nNumWindow:=LEN(aWindow)
RESTSCREEN(aWindow[nNumWindow,1],aWindow[nNumWindow,2],aWindow[nNumWindow,3]+1,;
aWindow[nNumWindow,4]+2,aWindow[nNumWindow,6])
IF aWindow[nNumWindow,7]
_ftLastWinColor()
ENDIF
ASHRINK(aWindow)
IF !EMPTY(aWindow)
_ftSetWinColor(W_CURR,W_SCREEN,W_VARIAB)
ELSE
_ftSetScrColor(STD_SCREEN,STD_VARIABLE)
ENDIF
RETURN NIL
*******************
/* _ftWinTitle(cTheTitle,cTopOrBot) --> NIL
* Print the top or bottom titles on the border of the currently active
* window.
* */
STATIC FUNCTION _ftWinTitle(cTheTitle,cTopOrBot)
LOCAL nCurWin :=LEN(aWindow)
LOCAL nLenTitle:=LEN(cTheTitle)
@ aWindow[nCurWin,IF(cTopOrBot=NIL,1,3)],(aWindow[nCurWin,4]-;
aWindow[nCurWin,2]-nLenTitle)/2+aWindow[nCurWin,2] SAY ' '+cTheTitle+' '
RETURN NIL
*******************
/* _ftShadow(nTop,nLeft,nBottom,nRight) --> NIL
* Create a shaddow on the screen in the coordinates given
* */
STATIC FUNCTION _ftShadow( nTop, nLeft, nBottom, nRight )
LOCAL theShadow := SAVESCREEN(nTop, nLeft, nBottom, nRight)
RESTSCREEN( nTop, nLeft, nBottom, nRight,;
TRANSFORM( theShadow,REPLICATE("X", LEN(theShadow)/2 ) ) )
RETURN NIL
**************
STATIC FUNCTION _ftRoundIt(nNumber, nPlaces) // Replacement ROUND()
nPlaces := IF( nPlaces == NIL, 0, nPlaces )
RETURN IF(nNumber < 0.0, -1.0, 1.0) * ;
INT( ABS(nNumber) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces
*************
STATIC FUNCTION _ftCharOdd(cString) // Return the ODD characters from string
cString := TRANSFORM(cString,REPLICATE("X", LEN(cString)/2 ) )
RETURN STRTRAN(cString,'')
**************